home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 007 / borg.arc / GLYPHE.BAS (.txt) < prev    next >
Encoding:
GW-BASIC  |  1985-12-29  |  12.8 KB  |  297 lines
  1. 2  '===========================================================================
  2. 3  '    GLYPHE-A CHARACTER GRAPHICS EDITOR FOR THE IBM PC
  3. 4  '   *REQUIREMENTS-ONE DISK DRIVE,MONOCHROME OR
  4. 5  '    COLOR DISPLAY.A MODIFIED PRINTER DRIVER IS
  5. 6  '    NEEDED TO PRINT THE PC`S CHARACTER GRAPHICS.
  6. 7  '     AUTHOR- CHARLES B. DUFF   03/6/83
  7. 8  '===========================================================================
  8. 10  DEFINT A-Z:ON ERROR GOTO 20000
  9. 30  FOR I=1 TO 10:KEY I,"":NEXT      'TURN OFF FUNCTION KEY DEFINITIONS
  10. 50  KEY OFF                            'ERASE 25TH LINE KEY HELP DISPLAY
  11. 70  DIM SCN$(88)
  12. 90  PIK$=SPACE$(80)                   'PICK BUFFER
  13. 100  TOF$=CHR$(12):LPI8$=CHR$(27)+"0":LPI6$=CHR$(27)+"2"  'CODES FOR MX-80
  14. 110  DIM DIAM$(10),BOX$(5),CRT$(6),SBOX$(4) 'DIAMOND,BOX AND SCREEN FIG.S
  15. 150  COORD$="<UNK! {00FA}><UNK! {00FA}><UNK! {00FA}><UNK! {00FA}>o<UNK! {00FA}><UNK! {00FA}><UNK! {00FA}><UNK! {00FA}>1<UNK! {00FA}><UNK! {00FA}><UNK! {00FA}><UNK! {00FA}>o<UNK! {00FA}><UNK! {00FA}><UNK! {00FA}><UNK! {00FA}>2<UNK! {00FA}><UNK! {00FA}><UNK! {00FA}><UNK! {00FA}>o<UNK! {00FA}><UNK! {00FA}><UNK! {00FA}><UNK! {00FA}>3<UNK! {00FA}><UNK! {00FA}><UNK! {00FA}><UNK! {00FA}>o<UNK! {00FA}><UNK! {00FA}><UNK! {00FA}><UNK! {00FA}>"+CHR$(127)+"<UNK! {00FA}><UNK! {00FA}><UNK! {00FA}><UNK! {00FA}>o<UNK! {00FA}><UNK! {00FA}><UNK! {00FA}><UNK! {00FA}>5<UNK! {00FA}><UNK! {00FA}><UNK! {00FA}><UNK! {00FA}>o<UNK! {00FA}><UNK! {00FA}><UNK! {00FA}><UNK! {00FA}>6<UNK! {00FA}><UNK! {00FA}><UNK! {00FA}><UNK! {00FA}>o<UNK! {00FA}><UNK! {00FA}><UNK! {00FA}><UNK! {00FA}>7<UNK! {00FA}><UNK! {00FA}><UNK! {00FA}><UNK! {00FA}>o<UNK! {00FA}><UNK! {00FA}><UNK! {00FA}><UNK! {00FA}>"
  16. 170  DIAM$(1)="      ^"      :BOX$(1)=" DELETE----------AUTO":SBOX$(1)="  DELETE-----AUTO"
  17. 190  DIAM$(2)="     / \"     :BOX$(2)="|            |":SBOX$(2)="|       |"
  18. 210  DIAM$(3)="   /    \"    :BOX$(3)="|            |":SBOX$(3)="|       |"
  19. 230  DIAM$(4)=" /        \"  :BOX$(4)="|            |":SBOX$(4)=" CLS-----'"
  20. 250  DIAM$(5)="<          >" :BOX$(5)=" CLS----------' "
  21. 270  DIAM$(6)=" \        /"  :CRT$(1)=" DELETEDELETE--------AUTOAUTO "
  22. 290  DIAM$(7)="  \     /"    :CRT$(2)="||          ||"
  23. 310  DIAM$(8)="    \ / "     :CRT$(3)="||          ||"
  24. 330  DIAM$(9)="     v"       :CRT$(4)="||          ||"
  25. 340  NU$=CHR$(0):            :CRT$(5)="||          ||"
  26. 344                          :CRT$(6)="CLSCLS----------''"
  27. 346  LINES=88   'MAX LINES IN EDITOR:88= 1 PRINTED PAGE AT 8 LP:
  28. 350  '==========================================================================
  29. 370   'PROMPT FOR FILES AND ENTER MAIN EDIT LOOP
  30. 390  '===========================================================================
  31. 400  CLS:PRINT"               GLYPHE  (C) Copyright 1983,Charles B. Duff"
  32. 404  PRINT:PRINT:
  33. 410  FILES:PRINT:PRINT:INPUT  "Input image file";IM$
  34. 430  INPUT "Output image file";OM$:CLS
  35. 440  IF OM$="" THEN OM$=IM$:IF OM$="" THEN CLOSE:CHAIN "b:graphics.bas"  'OUTPUT DEFAULTS TO IN
  36. 450  IF IM$="" THEN 570     'IF NO ENTRY THEN DON't open input file
  37. 470  OPEN IM$ AS #1 LEN=80:IF LOF(1)=0 THEN CLOSE:GOTO 570  'OPEN INPUT
  38. 490  FIELD #1,80 AS IL$           '80 CHR. TEXT FIELD
  39. 510  FOR LIN=1 TO LINES    'FILL BUFFER
  40. 530  GET #1,LIN:SCN$(LIN)=IL$
  41. 550  NEXT LIN
  42. 570  GMOD=1:SCOLD=1:SCNUM=1:GOSUB 1730   'DISPLAY THE FIRST PAGE
  43. 590  LOCATE 1,1,1          'HOME AND TURN ON THE CURSOR
  44. 610  GOSUB 2270            'PRINT SLAVE CURSOR ON 25TH LINE
  45. 630  A$=INKEY$:IF A$="" THEN 630   'GET A CHR.
  46. 650  IF LEN(A$)=2 THEN 710      'IF FUNCTION OR SPECIAL FUNCTION KEY
  47. 660  IF A$=CHR$(27) THEN GOSUB 3690:GOTO 610
  48. 670  IF A$=CHR$(13) AND CSRLIN=24 THEN GOSUB 3470:GOTO 610    'SCROLL
  49. 680  IF A$=CHR$(9) AND POS(0)<72 THEN LOCATE CSRLIN,POS(0)+8:GOTO 610
  50. 690  GOSUB 3770:PRINT A$;:OA$=A$:GOTO 610  'UPDATE BUFFER,DISPLAY AND LOOP
  51. 710  AV=ASC(MID$(A$,2,1))             'GET ASCII VALUE OF 2ND CHR.
  52. 712  '========================================================================
  53. 730  IF AV<71 THEN 1120 ELSE IF (AV>83 AND AV<115) THEN 1320   'IF FN KEY
  54. 750  ON AV-70 GOTO 810,830,870,610,930,610,950,610,1550,970,1090,1050,1010
  55. 790  GOTO 610
  56. 810  LOCATE 1,1:GOTO 610
  57. 830  IF CSRLIN>1 THEN LOCATE CSRLIN-1,POS(0):GOTO 610   'UP ARROW
  58. 850  GOTO 610
  59. 870  SCOLD=SCNUM:IF SCNUM>16 THEN SCNUM=SCNUM-16 ELSE SCNUM=1  'PG UP
  60. 890  GOSUB 1730:GOTO 610  'DISPLAY NEW PAGE
  61. 930  PRINT CHR$(29);:GOTO 610     'LEFT ARROW
  62. 950  PRINT CHR$(28);:GOTO 610     'RIGHT ARROW
  63. 970  IF CSRLIN<24 THEN LOCATE CSRLIN+1,POS(0):GOTO 610  'DOWN ARROW
  64. 990  GOTO 610
  65. 1010  GOSUB 2370:GOSUB 2550    `DELETE A CHR.
  66. 1030  GOTO 610
  67. 1050  GOSUB 2690:GOSUB 2550    `INSERT CHR.
  68. 1070  GOTO 610
  69. 1090  SCOLD=SCNUM:IF SCNUM<LINES-38 THEN SCNUM=SCNUM+16 ELSE SCNUM=LINES-23
  70. 1110  GOSUB 1730:GOTO 610      'PG DN-DISPLAY NEW PG.
  71. 1112  '=======================================================================
  72. 1120  IF AV<59 THEN 610    'THIS SECTION HANDLES F1-F10
  73. 1130  ON AV-58 GOTO 1140,1160,1180,1200,1220,1240,1260,1280,1300,1310
  74. 1132  GOTO 610
  75. 1140  A$=CHR$(218):GOTO 690   'FC 1-10 ARE GRAPHICS CHARACTERS
  76. 1160  A$="COLOR":GOTO 690   'FOR BUILDING TABLES,GRAPHS,ETC.
  77. 1180  A$="CLS":GOTO 690
  78. 1200  A$="'":GOTO 690
  79. 1220  A$="CALL":GOTO 690
  80. 1240  A$="SOUND":GOTO 690
  81. 1260  A$="BLOAD":GOTO 690
  82. 1280  A$="<0xB4!>":GOTO 690
  83. 1300  A$="MOTOR":GOTO 690
  84. 1310  A$="BSAVE":GOTO 690
  85. 1314  '=======================================================================
  86. 1320  IF AV>93 THEN 1480     'THIS SECTION HANDLES F11-F20
  87. 1322  ON AV-83 GOTO 1328,1330,1350,1370,1390,1410,1430,1450,1460,1470
  88. 1328  INSLIN=CSRLIN+SCNUM-1:GOSUB 3210:SCN$(INSLIN)=SPACE$(80):GOSUB 3890:GOTO 610                'INSERT LINE
  89. 1330  GOSUB 3310:GOSUB 3890:GOTO 610    'DELETE LINE
  90. 1350  GOSUB 3090:GOTO 610       'DROP
  91. 1370  GOSUB 2930:GOTO 610       'PICK
  92. 1390  GOSUB 4010:GOTO 610       'BOX
  93. 1410  GOSUB 4210:GOTO 610       'DIAMOND
  94. 1430  GOSUB 1570:GOTO 610  'save to disk
  95. 1450  GOSUB 5200:GOTO 610  'small box
  96. 1460  A$="<UNK! {FE22}>:GOTO 690
  97. 1470  A$="BEEP":GOTO 690
  98. 1472  '======================================================================
  99. 1480  IF AV>103 THEN 1520        'THIS SECTION HANDLES F21-30
  100. 1484  ON AV-93 GOTO 1490,1500,1510  'ROOM FOR EXPANSION
  101. 1486  GOTO 610
  102. 1490  GOSUB 4510:GOTO 610    'CRT SCREEN FIG.
  103. 1500  A$=OA$:GOTO 650      'F22 REMEMBERS LAST KEY PRESSES
  104. 1510  LOCATE 25,1:INPUT;"enter graphic mode (1=on, 0=off)";GMOD
  105. 1515  GOSUB 2150:GOTO 610
  106. 1518  '======================================================================
  107. 1520  IF AV=114 THEN GOSUB 5000:GOTO 610    'CTRL-PRT SC
  108. 1530  GOTO 610
  109. 1550  GOSUB 1570:COLOR 7,0:CLS:END 'END WAS PRESSED-SAVE AND EXIT
  110. 1570  OPEN OM$ AS #2 LEN=80    'WRITE IMAGE TO DISK
  111. 1590  FIELD #2,80 AS OL$        'OPEN RANDOM OUTPUT FILE RECL=80
  112. 1610  FOR LIN=1 TO LINES
  113. 1630  LSET OL$=SCN$(LIN)
  114. 1650  PUT #2,LIN
  115. 1670  NEXT LIN
  116. 1690  CLOSE #2:CLOSE #1
  117. 1710  CHAIN "b:graphics.bas"
  118. 1712  '***********************************************************************
  119. 1720  'begin subroutine code
  120. 1730  '=========================================================================
  121. 1750  'display screen given by scnum
  122. 1770  '=========================================================================
  123. 1790  CP=POS(0):CL=CSRLIN       'pickup cursor column and line
  124. 1810  CLS:GOSUB 2190
  125. 1830  FOR SCL=1 TO 23
  126. 1850  LOCATE SCL,1,0:PRINT SCN$(SCNUM+SCL-1);
  127. 1870  NEXT SCL
  128. 1890  LOCATE 24,1:PRINT MID$(SCN$(SCNUM+23),1,79);
  129. 1910  LOCATE CL,CP,1:RETURN  'restore cursor and return
  130. 2130  '=======================================================================
  131. 2150   '*print coordinates on 25th line
  132. 2170  '=======================================================================
  133. 2190  LOCATE 25,1:PRINT COORD$;
  134. 2210  RETURN
  135. 2230  '========================================================================
  136. 2250  '*print slave cursor at current column and current line indicator
  137. 2270  '========================================================================
  138. 2290  NCP=POS(0):NL=CSRLIN:LOCATE 25,CP,0:PRINT MID$(COORD$,CP,1);
  139. 2310  IF NCP<80 THEN LOCATE 25,NCP,0:COLOR 8,7:PRINT CHR$(127);
  140. 2330  LOCATE 25,1:PRINT USING "##";NL+SCNUM-1;:COLOR 7,0
  141. 2350  LOCATE NL,NCP,1:CP=NCP:RETURN
  142. 2370  '=========================================================================
  143. 2390   'delete a chr. from the current line
  144. 2410  '========================================================================
  145. 2430  SC=SCNUM+CSRLIN-1:CP=POS(0)
  146. 2470  SCN$(SC)=LEFT$(SCN$(SC),CP-1)+RIGHT$(SCN$(SC),80-CP)+" "
  147. 2530  RETURN
  148. 2550  '=======================================================================
  149. 2570  '*print the current line from screen buffer
  150. 2590  '=======================================================================
  151. 2610  CP=POS(0):CL=CSRLIN
  152. 2630  SC=SCNUM+CL-1:IF CL=24 THEN 2670
  153. 2650  LOCATE CL,1,0:PRINT SCN$(SC);:LOCATE CL,CP,1:RETURN
  154. 2670  LOCATE 24,1,0:PRINT MID$(SCN$(SC),1,79);:LOCATE CL,CP,1:RETURN
  155. 2690  '=======================================================================
  156. 2710   '*inset a space in current line
  157. 2730  '=======================================================================
  158. 2750  SC=SCNUM+CSRLIN-1:CP=POS(0)
  159. 2790  SCN$(SC)=LEFT$(SCN$(SC),CP-1)+" "+MID$(SCN$(SC),CP,80-CP)
  160. 2870  RETURN
  161. 2890  '=======================================================================
  162. 2910   '*pick a line from scn$ to the pick buffer
  163. 2930  '=======================================================================
  164. 3010  PIK$=SCN$(CSRLIN+SCNUM-1)
  165. 3030  RETURN
  166. 3050  '======================================================================
  167. 3070   '*drop a line to the screen(insert)
  168. 3090  '======================================================================
  169. 3110  SC=CSRLIN+SCNUM-1:IF SC>LINES THEN RETURN
  170. 3130  INSLIN=SC:GOSUB 3210
  171. 3150  SCN$(SC)=PIK$:GOSUB 3830:RETURN
  172. 3170  '=====================================================================
  173. 3190   '*move lines down in scn$ for insert
  174. 3210  '======================================================================
  175. 3230  FOR LIN=LINES TO INSLIN+1 STEP -1
  176. 3250  SCN$(LIN)=SCN$(LIN-1)
  177. 3270  NEXT LIN
  178. 3290  RETURN
  179. 3310  '======================================================================
  180. 3330   '*delete a line from the screen
  181. 3350  '=======================================================================
  182. 3370  SC=CSRLIN+SCNUM-1
  183. 3390  FOR LIN=SC TO LINES-1
  184. 3410  SCN$(LIN)=SCN$(LIN+1)
  185. 3430  NEXT LIN
  186. 3450  SCN$(LINES)=SPACE$(80):RETURN
  187. 3470  '=======================================================================
  188. 3490   'handle a scroll from a cr on line 24
  189. 3510  '=======================================================================
  190. 3590  IF SCNUM>LINES-24 THEN LOCATE 24,1,1:RETURN
  191. 3610  PRINT A$;:LOCATE 24,1,0:PRINT MID$(SCN$(SCNUM+24),1,79);
  192. 3630  SCNUM=SCNUM+1:GOSUB 2270:LOCATE 24,1,1:RETURN
  193. 3650   '======================================================================
  194. 3670  '*ESC TO QUIT WITHOUT SAVE
  195. 3690  '=======================================================================
  196. 3700  CP=POS(0):CL=CSRLIN       'SAVE CURSOR POSITION
  197. 3710  LOCATE 25,1:INPUT;"Quit without saving (Y or N)";ANS$
  198. 3730  IF ANS$="Y" OR ANS$="y" THEN CLS:CHAIN "b:graphics.bas"
  199. 3750  GOSUB 2170:LOCATE CL,CP:RETURN
  200. 3770  '======================================================================
  201. 3780   '*update buffer with character entered, and
  202. 3784  '*handle a scroll if at 24.80 and not beyond
  203. 3786   '*the end of the screen buffer. add 127 to code if graphics mode
  204. 3788   '=====================================================================
  205. 3789  AV=ASC(A$):IF GMOD=1 AND AV<>13 AND AV<>32 AND AV<127 THEN A$=CHR$(AV+127)
  206. 3790  IF A$<>CHR$(13) THEN MID$(SCN$(SCNUM+CSRLIN-1),POS(0),1)=A$
  207. 3800  IF CSRLIN<24 OR POS(0)<80 THEN RETURN
  208. 3804  IF SCNUM>LINES-24 THEN RETURN
  209. 3806  SCNUM=SCNUM+1:RETURN
  210. 3810  RETURN
  211. 3830  '=======================================================================
  212. 3850  '*print screen from current line down
  213. 3870  '=======================================================================
  214. 3890  CP=POS(0):CL=CSRLIN
  215. 3910  FOR LIN=CL TO 23
  216. 3930  LOCATE LIN,1:PRINT SCN$(SCNUM+LIN-1);
  217. 3950  NEXT LIN
  218. 3970  LOCATE 24,1:PRINT MID$(SCN$(SCNUM+23),1,79);
  219. 3990  LOCATE CL,CP:RETURN
  220. 4010   '=======================================================================
  221. 4030  '*print a box with top center at cursor
  222. 4050  '========================================================================
  223. 4070  SC=SCNUM+CSRLIN-1:
  224. 4090  IF POS(0)<(LEN(BOX$(1))/2)+1 THEN RETURN
  225. 4110  CP=POS(0)-(LEN(BOX$(1))/2)
  226. 4130  FOR LIN=1 TO 5:IF SC+LIN-1=LINES+1 THEN 4190
  227. 4150  MID$(SCN$(SC+LIN-1),CP,LEN(BOX$(1)))=BOX$(LIN)
  228. 4170  NEXT LIN
  229. 4190  GOSUB 3870:RETURN
  230. 4210  '======================================================================
  231. 4230  '*print a diamond with top at cursor
  232. 4250  '======================================================================
  233. 4270  SC=SCNUM+CSRLIN-1
  234. 4290  IF POS(0)<LEN(DIAM$(5))/2 THEN RETURN
  235. 4310  CP=POS(0)-(LEN(DIAM$(5))/2)
  236. 4330  FOR LIN=1 TO 9:IF SC+LIN-1=LINES+1 THEN 4390
  237. 4350  MID$(SCN$(SC+LIN-1),CP,LEN(DIAM$(5)))=DIAM$(LIN)
  238. 4370  NEXT LIN
  239. 4390  GOSUB 3870:RETURN
  240. 4510  '=====================================================================
  241. 4530  '*print a crt screen with top center at cursor
  242. 4550  '====================================================================
  243. 4570  SC=SCNUM+CSRLIN-1
  244. 4590  IF POS(0)<(LEN(CRT$(1))/2)+1 THEN RETURN
  245. 4610  CP=POS(0)-(LEN(CRT$(1))/2)
  246. 4630  FOR LIN=1 TO 6:IF SC+LIN-1=LINES+1 THEN 4690
  247. 4650  MID$(SCN$(SC+LIN-1),CP,LEN(CRT$(1)))=CRT$(LIN)
  248. 4670  NEXT LIN
  249. 4690  GOSUB 3870:RETURN
  250. 5000  '======================================================================
  251. 5010  '*print the contents of the screen buffer
  252. 5020  '*on the printer
  253. 5030  '======================================================================
  254. 5032  LPRINT LPI8$+TOF$;     '(mx) set 8 lpi,top of form
  255. 5040  FOR LIN=1 TO LINES
  256. 5044  IF INKEY$="" THEN 5050
  257. 5046  CP=POS(0):CL=CSRLIN:LOCATE 25,1:INPUT;"Quit printing (y or n)";ANS$
  258. 5048  GOSUB 2170:LOCATE CL,CP:IF ANS$="y" OR ANS$+"Y" THEN 5070
  259. 5050  LPRINT SCN$(LIN);
  260. 5060  NEXT LIN
  261. 5070  LPRINT LPI6$;     'restore 6 lpi
  262. 5080  RETURN
  263. 5200  '======================================================================
  264. 5220  '*print a small bow with top center at cursor
  265. 5240  '======================================================================
  266. 5280  SC=SCNUM+CSRLIN-1
  267. 5300  IF POS(0)<(LEN(SBOX$(1))/2)+1 THEN RETURN    'check if off scrn
  268. 5320  CP=POS(0)-(LEN(SBOX$(1))/2)
  269. 5340  FOR LIN=1 TO 4:IF SC+LIN-1=LINES+1 THEN 4690
  270. 5360  MID$(SCN$(SC+LIN-1),CP,LEN(SBOX$(1)))=SBOX$(LIN)  'store in scn$
  271. 5380  NEXT LIN
  272. 5400  GOSUB 3870:RETURN
  273. 20000  '=================================================================
  274. 20010  '*error handler
  275. 20020  '=================================================================
  276. 20030  IF ERL<>5050 THEN 20200
  277. 20040  CP=POS(0):CL=CSRLIN:LOCATE 25,1:INPUT "Printer error-quit printing (y or n)";ANS$
  278. 20050  GOSUB 2170:LOCATE CL,CP:IF ANS$="Y" OR ANS$="y" THEN RESUME 5080
  279. 20060  RESUME 5050
  280. 20200  IF ERL<>470 THEN 20400    'input open errors
  281. 20220  CP=POS(0):CL=CSRLIN:LOCATE 25,1:INPUT "Input open error-abort(Y or N)";ANS$
  282. 20230  GOSUB 2170:LOCATE CL,CP:IF ANS$="Y" OR ANS$="y" THEN RESUME 570
  283. 20240  RESUME 470
  284. 20400  IF ERL<>530 THEN 20600     'input read errors
  285. 20420  CP=POS(0):CL=CSRLIN:LOCATE 25,1:INPUT;"Input read error-abort (y or n)";ANS$
  286. 20430  GOSUB 2170:LOCATE CL,CP:IF ANS$="Y" OR ANS$="y" THEN RESUME 570
  287. 20440  RESUME 530
  288. 20600  IF ERL<>1570 THEN 20800     'output open errors
  289. 20620  CP=POS(0):CL=CSRLIN:LOCATE 25,1:INPUT;"Output open error-abort (Y or N)";ANS$
  290. 20630  GOSUB 2170:LOCATE CL,CP:IF ANS$="Y" OR ANS$="y" THEN RESUME 1690
  291. 20640  RESUME 1570
  292. 20800  IF ERL<> 1650 THEN 20900    'output write errors
  293. 20820  CP=POS(0):CL=CSRLIN:LOCATE 25,1:INPUT;"Write error-abort (Y or N)";ANS$
  294. 20830  GOSUB 2170:LOCATE CL,CP:IF ANS$="Y" OR ANS$="y" THEN RESUME 1690
  295. 20840  RESUME 1650
  296. 20900  ON ERROR GOTO 0
  297.